home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / LISP / XLISP / XLISP21S / sources / c / xlimage < prev    next >
Text File  |  1992-04-25  |  12KB  |  460 lines
  1. /* xlimage - xlisp memory image save/restore functions */
  2. /*  Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use   */
  5. /* modified so that offset is in sizeof(node) units */
  6. #include "xlisp.h"
  7.  
  8. #ifdef SAVERESTORE
  9.  
  10. #define FILENIL ((OFFTYPE)0)    /* value of NIL in a file */
  11.  
  12. /* external variables */
  13. extern LVAL obarray,xlenv,xlfenv,xldenv,s_gchook,s_gcflag;
  14. extern long nnodes,nfree,total;
  15. extern int anodes,nsegs,gccalls;
  16. extern struct segment *segs,*lastseg,*fixseg,*charseg;
  17. extern CONTEXT *xlcontext;
  18. extern LVAL fnodes;
  19. extern int ftabsize;    /* TAA MOD -- added validity check */
  20.  
  21. /* local variables */
  22. static OFFTYPE off,foff;
  23. static FILEP fp;
  24.  
  25. /* forward declarations */
  26. #ifdef ANSI
  27. OFFTYPE NEAR readptr(void);
  28. OFFTYPE NEAR cvoptr(LVAL p);
  29. LVAL NEAR cviptr(OFFTYPE o);
  30. void NEAR freeimage(void);
  31. void NEAR setoffset(void);
  32. void NEAR writenode(LVAL node);
  33. void NEAR writeptr(OFFTYPE off);
  34. void NEAR readnode(int type, LVAL node);
  35. #else
  36. OFFTYPE readptr();
  37. OFFTYPE cvoptr();
  38. LVAL cviptr();
  39. VOID freeimage();
  40. VOID setoffset();
  41. VOID writenode();
  42. VOID writeptr();
  43. VOID readnode();
  44. #endif
  45.  
  46. /* xlisave - save the memory image */
  47. int xlisave(fname)
  48.   char *fname;
  49. {
  50.     char fullname[STRMAX+1];
  51.     SEGMENT *seg;
  52.     int n,i,max;
  53.     LVAL p;
  54.  
  55.     /* default the extension */
  56.     if (needsextension(fname)) {
  57.         strcpy(fullname,fname);
  58.         strcat(fullname,".wks");
  59.         fname = fullname;
  60.     }
  61.  
  62.     /* open the output file */
  63.  
  64.     if ((fp = OSBOPEN(fname,CREATE_WR)) == CLOSED)
  65.         return (FALSE);
  66.  
  67.     /* first call the garbage collector to clean up memory */
  68.     gc();
  69.  
  70.     /* write out size of ftab (used as validity check) TAA MOD */
  71.     writeptr((OFFTYPE)ftabsize);
  72.  
  73.     /* write out the pointer to the *obarray* symbol */
  74.     writeptr(cvoptr(obarray));
  75.  
  76.     /* write out components of NIL other than value, which must be NIL */
  77.     writeptr(cvoptr(getfunction(NIL)));
  78.     writeptr(cvoptr(getplist(NIL)));
  79.     writeptr(cvoptr(getpname(NIL)));
  80.  
  81.     /* setup the initial file offsets */
  82.     off = foff = (OFFTYPE)2;
  83.  
  84.     /* write out all nodes that are still in use */
  85.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  86.         p = &seg->sg_nodes[0];
  87.         for (n = seg->sg_size; --n >= 0; ++p, off++)
  88.             switch (ntype(p)) {
  89.             case FREE:
  90.                 break;
  91.             case CONS:
  92.             case USTREAM:
  93.                 setoffset();
  94.                 OSPUTC(p->n_type,fp);
  95.                 writeptr(cvoptr(car(p)));
  96.                 writeptr(cvoptr(cdr(p)));
  97.                 foff++;
  98.                 break;
  99.             default:
  100.                 setoffset();
  101.                 writenode(p);
  102.                 break;
  103.         }
  104.     }
  105.  
  106.     /* write the terminator */
  107.     OSPUTC(FREE,fp);
  108.     writeptr((OFFTYPE)0);
  109.  
  110.     /* write out data portion of SYMBOL/VECTOR/OBJECT/STRING/CLOSURE nodes */
  111.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  112.         p = &seg->sg_nodes[0];
  113.         for (n = seg->sg_size; --n >= 0; ++p)
  114.             switch (ntype(p)) {
  115.             /* $putpatch.c$: "MODULE_XLIMAGE_C_XLISAVE" */
  116.             case SYMBOL:
  117.             case OBJECT:
  118.             case VECTOR:
  119.             case CLOSURE:
  120.             case STRUCT:
  121. #ifdef COMPLX
  122.             case COMPLEX:
  123. #endif
  124.                 max = getsize(p);
  125.                 for (i = 0; i < max; ++i)
  126.                     writeptr(cvoptr(getelement(p,i)));
  127.                 break;
  128.             case STRING:
  129.                 max = getslength(p)+1;
  130.                 OSWRITE(getstring(p),1,max,fp);
  131.                 break;
  132. #ifdef FILETABLE
  133.             case STREAM:
  134.                 if (getfile(p) > CONSOLE ) {
  135.                     OSWRITE(filetab[getfile(p)].tname,1,FNAMEMAX,fp);
  136.                     *(long *)buf = OSTELL(getfile(p));
  137.                     OSWRITE(buf,1,sizeof(long),fp);
  138.                 }
  139.                 break;
  140. #endif
  141.         }
  142.     }
  143.  
  144.     /* close the output file */
  145.     OSCLOSE(fp);
  146.  
  147.     /* return successfully */
  148.     return (TRUE);
  149. }
  150.  
  151. /* xlirestore - restore a saved memory image */
  152. int xlirestore(fname)
  153.   char *fname;
  154. {
  155.     extern FUNDEF funtab[];
  156.     char fullname[STRMAX+1];
  157.     int n,i,max,type;
  158.     SEGMENT *seg;
  159.     LVAL p;
  160.  
  161.     /* default the extension */
  162.     if (needsextension(fname)) {
  163.         strncpy(fullname,fname,STRMAX-4);
  164.         strcat(fullname,".wks");
  165.         fname = fullname;
  166.     }
  167.  
  168.     /* open the file */
  169. #ifdef PATHNAMES
  170.     if ((fp = ospopen(fname,FALSE)) == CLOSED)
  171. #else
  172.     if ((fp = OSBOPEN(fname,OPEN_RO)) == CLOSED)
  173. #endif
  174.         return (FALSE);
  175.  
  176.     /* Check for file validity  TAA MOD */
  177.     if (readptr() != (OFFTYPE) ftabsize) {
  178.         OSCLOSE(fp);    /* close it -- we failed */
  179.         return (FALSE);
  180.     }
  181.  
  182.     /* free the old memory image */
  183.     freeimage();
  184.  
  185.     /* initialize */
  186.     off = (OFFTYPE)2;
  187.     total = nnodes = nfree = 0L;
  188.     fnodes = NIL;
  189.     segs = lastseg = NULL;
  190.     nsegs = gccalls = 0;
  191.     xlenv = xlfenv = xldenv = s_gchook = s_gcflag = NIL;
  192.     xlstack = xlstkbase + EDEPTH;
  193.     xlfp = xlsp = xlargstkbase;
  194.     *xlsp++ = NIL;
  195.     xlcontext = NULL;
  196.  
  197.     /* create the fixnum segment */
  198.     if ((fixseg = newsegment(SFIXSIZE)) == NULL)
  199.         xlfatal("insufficient memory - fixnum segment");
  200.  
  201.     /* create the character segment */
  202.     if ((charseg = newsegment(CHARSIZE)) == NULL)
  203.         xlfatal("insufficient memory - character segment");
  204.  
  205.     /* read the pointer to the *obarray* symbol */
  206.     obarray = cviptr(readptr());
  207.  
  208.     /* read components of NIL other than value, which must be NIL */
  209.     setfunction(NIL, cviptr(readptr()));
  210.     setplist(NIL, cviptr(readptr()));
  211.     setpname(NIL, cviptr(readptr()));
  212.  
  213.     /* read each node */
  214.     while ((type = OSGETC(fp)) >= 0) {
  215.         switch (type) {
  216.         case FREE:
  217.             if ((off = readptr()) == (OFFTYPE)0)
  218.                 goto done;
  219.             break;
  220.         case CONS:
  221.         case USTREAM:
  222.             p = cviptr(off);
  223.             p->n_type = type;
  224.             rplaca(p,cviptr(readptr()));
  225.             rplacd(p,cviptr(readptr()));
  226.             off++;
  227.             break;
  228.         default:
  229.             readnode(type,cviptr(off));
  230.             off++;
  231.             break;
  232.         }
  233.     }
  234. done:
  235.  
  236.  
  237.     /* read the data portion of SYMBOL/VECTOR/OBJECT/STRING/CLOSURE nodes */
  238.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  239.     p = &seg->sg_nodes[0];
  240.     for (n = seg->sg_size; --n >= 0; ++p)
  241.         switch (ntype(p)) {
  242.         /* $putpatch.c$: "MODULE_XLIMAGE_C_XLIRESTORE" */
  243.         case SYMBOL:
  244.         case OBJECT:
  245.         case VECTOR:
  246.         case CLOSURE:
  247.         case STRUCT:
  248. #ifdef COMPLX
  249.         case COMPLEX:
  250. #endif
  251.             max = getsize(p);
  252.             if ((p->n_vdata = (LVAL *)MALLOC(max * sizeof(LVAL))) == NULL)
  253.                 xlfatal("insufficient memory - vector");
  254.             total += (long)(max * sizeof(LVAL));
  255.             for (i = 0; i < max; ++i)
  256.                 setelement(p,i,cviptr(readptr()));
  257.             break;
  258.         case STRING:
  259.             max = getslength(p)+1;
  260.             if ((p->n_string = (char *)MALLOC(max)) == NULL)
  261.                 xlfatal("insufficient memory - string");
  262.             total += (long)max;
  263.             if (OSREAD(getstring(p),1,max,fp) != max)
  264.                 xlfatal("image file corrupted");
  265.             break;
  266.         case STREAM:
  267. #ifdef FILETABLE
  268.             if (getfile(p) > CONSOLE) { /* actual file to modify */
  269.                 unsigned long fpos;
  270.                 FILEP f;
  271.  
  272.                 if (OSREAD(buf, 1, FNAMEMAX, fp) != FNAMEMAX ||
  273.                     OSREAD(&fpos, 1, sizeof(long), fp) != sizeof(long))
  274.                         xlfatal("image file corrupted");
  275.                 /* open file in same type, file must exist to succeed */
  276.                 f = ((p->n_sflags & S_BINARY)? OSBOPEN : OSAOPEN)
  277.                     (buf, (p->n_sflags&S_FORWRITING)? OPEN_UPDATE: OPEN_RO);
  278.                 setfile(p, f);
  279.                 if (f != CLOSED) {  /* position to same point,
  280.                                         or end if file too short */
  281.                     OSSEEKEND(f);
  282.                     if (OSTELL(f) > fpos) OSSEEK(f, fpos);
  283.                 }
  284.             }
  285.             break;
  286. #else
  287.             setfile(p,NULL);
  288.             break;
  289. #endif
  290.         case SUBR:
  291.         case FSUBR:
  292.             p->n_subr = funtab[getoffset(p)].fd_subr;
  293.             break;
  294.         }
  295.     }
  296.  
  297.  
  298.     /* close the input file */
  299.     OSCLOSE(fp);
  300.  
  301.     /* collect to initialize the free space */
  302.     gc();
  303.  
  304.     /* lookup all of the symbols the interpreter uses */
  305.     xlsymbols();
  306.  
  307.     /* return successfully */
  308.     return (TRUE);
  309. }
  310.  
  311. /* freeimage - free the current memory image */
  312. LOCAL VOID NEAR freeimage()
  313. {
  314.     SEGMENT *seg,*next;
  315.     FILEP fp;
  316.     LVAL p;
  317.     int n;
  318.  
  319.     /* free the data portion of SYMBOL/VECTOR/OBJECT/STRING nodes */
  320.     for (seg = segs; seg != NULL; seg = next) {
  321.     p = &seg->sg_nodes[0];
  322.     for (n = seg->sg_size; --n >= 0; ++p)
  323.         switch (ntype(p)) {
  324.         /* $putpatch.c$: "MODULE_XLIMAGE_C_FREEIMAGE" */
  325.         case SYMBOL:
  326.         case OBJECT:
  327.         case VECTOR:
  328.         case CLOSURE:
  329.         case STRUCT:
  330. #ifdef COMPLX
  331.         case COMPLEX:
  332. #endif
  333.             if (p->n_vsize)
  334.                 MFREE(p->n_vdata);
  335.             break;
  336.         case STRING:
  337.             if (getstring(p)!=NULL)
  338.                 MFREE(getstring(p));
  339.             break;
  340.         case STREAM:
  341.             if (((fp = getfile(p)) != CLOSED) &&
  342.                 (fp != STDIN && fp != STDOUT && fp != CONSOLE))  /* TAA BUG FIX */
  343.             OSCLOSE(fp);
  344.             break;
  345.         }
  346.     next = seg->sg_next;
  347.     MFREE(seg);
  348.     }
  349. }
  350.  
  351. /* setoffset - output a positioning command if nodes have been skipped */
  352. LOCAL VOID NEAR setoffset()
  353. {
  354.     if (off != foff) {
  355.         OSPUTC(FREE,fp);
  356.         writeptr(off);
  357.         foff = off;
  358.     }
  359. }
  360.  
  361. /* writenode - write a node to a file */
  362. LOCAL VOID NEAR writenode(node)
  363.   LVAL node;
  364. {
  365.     OSPUTC(node->n_type,fp);
  366.     OSWRITE(&node->n_info, sizeof(union ninfo), 1, fp);
  367. #ifdef ALIGN32
  368.     if (node->n_type == SYMBOL) OSPUTC(node->n_spflags,fp);
  369. #endif
  370.     foff++;
  371. }
  372.  
  373. /* writeptr - write a pointer to a file */
  374. LOCAL VOID NEAR writeptr(off)
  375.   OFFTYPE off;
  376. {
  377.     OSWRITE(&off, sizeof(OFFTYPE), 1, fp);
  378. }
  379.  
  380. /* readnode - read a node */
  381. LOCAL VOID NEAR readnode(type,node)
  382.   int type; LVAL node;
  383. {
  384.     node->n_type = type;
  385.     if (OSREAD(&node->n_info, sizeof(union ninfo), 1, fp) != 1)
  386.         xlfatal("image file corrupted");
  387. #ifdef ALIGN32
  388.     if (type == SYMBOL) node->n_spflags = OSGETC(fp);
  389. #endif
  390. }
  391.  
  392. /* readptr - read a pointer */
  393. LOCAL OFFTYPE NEAR readptr()
  394. {
  395.     OFFTYPE off;
  396.     if(OSREAD(&off, sizeof(OFFTYPE), 1, fp) != 1)
  397.         xlfatal("image file corrupted");
  398.     return (off);
  399. }
  400.  
  401. /* cviptr - convert a pointer on input */
  402. LOCAL LVAL NEAR cviptr(o)
  403.   OFFTYPE o;
  404. {
  405.     OFFTYPE off = (OFFTYPE)2;
  406.     SEGMENT *seg;
  407.  
  408.     /* check for nil */
  409.     if (o == FILENIL)
  410.         return (NIL);
  411.  
  412.     /* compute a pointer for this offset */
  413.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  414.         if (o < off + (OFFTYPE)seg->sg_size)
  415.             return (seg->sg_nodes + (unsigned int)(o - off));
  416.         off += (OFFTYPE)seg->sg_size;
  417.     }
  418.  
  419.     /* create new segments if necessary */
  420.     for (;;) {
  421.     /* create the next segment */
  422.         if ((seg = newsegment(anodes)) == NULL)
  423.             xlfatal("insufficient memory - segment");
  424.  
  425.  
  426.     /* check to see if the offset is in this segment */
  427.         if (o < off + (OFFTYPE)seg->sg_size)
  428.             return (seg->sg_nodes + (unsigned int)(o - off));
  429.         off += (OFFTYPE)seg->sg_size;
  430.     }
  431. }
  432.  
  433. /* cvoptr - convert a pointer on output */
  434. LOCAL OFFTYPE NEAR cvoptr(p)
  435.   LVAL p;
  436. {
  437.     OFFTYPE off = (OFFTYPE)2;
  438.     SEGMENT *seg;
  439.     OFFTYPE np = CVPTR(p);
  440.  
  441.     /* check for nil */
  442.     if (null(p))
  443.         return (FILENIL);
  444.  
  445.     /* compute an offset for this pointer */
  446.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  447.         if (np >= CVPTR(&seg->sg_nodes[0]) &&
  448.             np <  CVPTR(&seg->sg_nodes[seg->sg_size]))
  449.                 return (off+ ((np-CVPTR(seg->sg_nodes))/sizeof(struct node)));
  450.             off += (OFFTYPE)seg->sg_size;
  451.     }
  452.  
  453.     /* pointer not within any segment */
  454.     xlerror("bad pointer found during image save",p);
  455.     return (0); /* fake out compiler warning */
  456. }
  457. #endif
  458.  
  459.  
  460.